## Warning: package 'reactable' was built under R version 4.1.3## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --## v ggplot2 3.3.5 v purrr 0.3.4
## v tibble 3.1.2 v dplyr 1.0.7
## v tidyr 1.1.3 v stringr 1.4.0
## v readr 2.0.0 v forcats 0.5.1## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()## `summarise()` has grouped output by 'state'. You can override using the `.groups` argument.
## `summarise()` has grouped output by 'state'. You can override using the `.groups` argument.
## `summarise()` has grouped output by 'state'. You can override using the `.groups` argument.
## `summarise()` has grouped output by 'state'. You can override using the `.groups` argument.## `mutate_if()` ignored the following grouping variables:
## Column `state`
*IR=incidence rate, MR=mortality rate, TR=testing rate, TPR=test-positivity ratio, Rt=time-varying reproductive number, BOR=Bed-occupancy rate, IOR= ICU-occupancy rate, VOR=ventilator-utilisation rate, % change calculated as the percentage change of indicator compared to the last week
library(reactable)
library(htmltools)
library(tidyverse)
transmission <- read.csv('../data/transmission.csv')
testing <- read.csv('../data/testing.csv')
capacity <- read.csv('../data/capacity.csv')
mobility <- read.csv('../data/mobility.csv')
vaccination <- read.csv('../data/vaccination.csv')
transmission_7day <- transmission %>% group_by(state) %>%
mutate(date=as.Date(date),
ir_7day=round(as.numeric(ir_7day),1),
mr_7day=round(as.numeric(mr_7day),1),
rt=round(as.numeric(rt),1),
lower=round(as.numeric(lower),1),
upper=round(as.numeric(upper),1)) %>%
filter(date>max(date)-14) %>%
mutate(week=ifelse(date>max(date)-7,1,2)) %>%
ungroup() %>% as.data.frame() %>%
group_by(state, week) %>%
summarise(mean_ir=mean(ir_7day),
mean_mr=mean(mr_7day),
mean_rt=mean(rt),
mean_lower=mean(lower),
mean_upper=mean(upper)) %>%
ungroup() %>%
group_by(state) %>%
mutate(perc_change_ir=round(((mean_ir-lag(mean_ir))/lag(mean_ir))*100,1),
perc_change_mr=round(((mean_mr-lag(mean_mr))/lag(mean_mr))*100,1),
perc_change_rt=round(((mean_rt-lag(mean_rt))/lag(mean_rt))*100,1),
mean_rt_full=paste0(round(mean_rt,2), " (", round(mean_lower,1), ", ", round(mean_upper,1), ")")) %>%
filter(week==2) %>%
select(-week)
test_7day <- testing %>% group_by(state) %>%
mutate(date=as.Date(date),
ma_7day_tr=round(as.numeric(ma_7day_tr),1),
ma_7day_tpr=ma_7day_tpr/100) %>%
filter(date>max(date)-14) %>%
mutate(week=ifelse(date>max(date)-7,1,2)) %>%
ungroup() %>% as.data.frame() %>%
group_by(state, week) %>%
summarise(mean_tpr=mean(ma_7day_tpr),
mean_tr=mean(ma_7day_tr)) %>%
ungroup() %>%
group_by(state) %>%
mutate(perc_change_tpr=round(((mean_tpr-lag(mean_tpr))/lag(mean_tpr))*100,1),
perc_change_tr=round(((mean_tr-lag(mean_tr))/lag(mean_tr))*100,1),
trend_tpr=ifelse(perc_change_tpr<0, "down",
ifelse(perc_change_tpr>0, "up", "unchanged"))) %>%
filter(week==2) %>%
select(-week)
capacity_7day <- capacity %>% group_by(state) %>%
mutate(date=as.Date(date),
bor=bor/100,
ior=ior/100,
vor=vor/100) %>%
filter(date>max(date)-14) %>%
mutate(week=ifelse(date>max(date)-7,1,2)) %>%
ungroup() %>% as.data.frame() %>%
group_by(state, week) %>%
summarise(mean_bor=mean(bor),
mean_ior=mean(ior),
mean_vor=mean(vor)) %>%
ungroup() %>%
group_by(state) %>%
mutate(perc_change_bor=round(((mean_bor-lag(mean_bor))/lag(mean_bor))*100,1),
perc_change_ior=round(((mean_ior-lag(mean_ior))/lag(mean_ior))*100,1),
perc_change_vor=round(((mean_vor-lag(mean_vor))/lag(mean_vor))*100,1),
trend_bor=ifelse(perc_change_bor<0, "down",
ifelse(perc_change_bor>0, "up", "unchanged")),
trend_ior=ifelse(perc_change_ior<0, "down",
ifelse(perc_change_ior>0, "up", "unchanged")),
trend_vor=ifelse(perc_change_vor<0, "down",
ifelse(perc_change_vor>0, "up", "unchanged"))) %>%
filter(week==2) %>%
select(-week)
vaccination_7day <- vaccination %>% group_by(state) %>%
mutate(date=as.Date(date),
perc_vax2=perc_vax2/100,
perc_booster=perc_booster/100) %>%
filter(date>max(date)-14) %>%
mutate(week=ifelse(date>max(date)-7,1,2)) %>%
ungroup() %>% as.data.frame() %>%
group_by(state, week) %>%
summarise(max_vax2=max(perc_vax2),
max_booster=max(perc_booster)) %>%
ungroup() %>%
group_by(state) %>%
mutate(perc_vax2_change=round(((max_vax2-lag(max_vax2))/lag(max_vax2))*100,1),
perc_booster_change=round(((max_booster-lag(max_booster))/lag(max_booster))*100,1),
trend_vax2=ifelse(perc_vax2_change<0, "down",
ifelse(perc_vax2_change>0, "up", "unchanged")),
trend_booster=ifelse(perc_booster_change<0, "down",
ifelse(perc_booster_change>0, "up", "unchanged"))) %>%
filter(week==2) %>%
select(-week)
#join all the sets
epid_report <- left_join(transmission_7day, test_7day, by="state") %>%
left_join(capacity_7day, by="state") %>%
left_join(vaccination_7day, by="state") %>%
na.omit() %>%
mutate_if(is.numeric, function(x) ifelse(is.infinite(x), 0, x)) %>%
as.data.frame() %>% mutate_if(is.numeric, round, digits=2)
epid_report_msia <- epid_report %>% filter(state=="Malaysia") %>% mutate(state=as.factor(state))
epid_report_state <- epid_report %>% filter(state!="Malaysia") %>%
mutate(state=as.factor(state)) %>%
arrange(desc(mean_ir))
epid_report <- bind_rows(epid_report_msia, epid_report_state)
#write epid report to csv
write.csv(epid_report, "../data/epid_report.csv")
#prepare the columns for the epid report
trans_cols <- c("mean_ir", "perc_change_ir", "mean_mr", "perc_change_mr", "mean_rt_full", "perc_change_rt")
test_cols <- c("mean_tpr", "trend_tpr", "mean_tr", "perc_change_tr")
capacity_cols <- c("mean_bor", "trend_bor", "mean_ior", "trend_ior", "mean_vor", "trend_vor")
vax_cols <- c("max_vax2", "trend_vax2", "max_booster", "trend_booster")
#all colims
epid_report <- epid_report[, c("state", trans_cols, test_cols, capacity_cols, vax_cols)]
change_column <- function(maxWidth = 60, ...) {
colDef(maxWidth = maxWidth, align = "center", class = "cell number", ...)
}
number_column <- function(class = NULL, ...) {
colDef(align = "center", class = paste("cell number", class), ...)
}
number_col_column <- function(class = NULL, ...) {
colDef(maxWidth = 60, align = "center", class = paste("cell number", class),
...)
}
perc_column <- function(maxWidth = 40, class = NULL, ...) {
colDef(
align = "center",
cell = format_pct,
maxWidth = maxWidth,
class = paste("cell number", class),
style = function(value) {
# Lighter color for <1%
if (value < 0.01) {
list(color = "#aaa")
} else {
list(color = "#111", background = knockout_pct_color(value))
}
},
...
)
}
format_pct <- function(value) {
if (value == 0) " \u2013 " # en dash for 0%
else if (value == 1) "\u2713" # checkmark for 100%
else if (value < 0.01) " <1%"
else if (value > 0.99) ">99%"
else formatC(paste0(round(value * 100), "%"), width = 4)
}
make_color_pal <- function(colors, bias = 1) {
get_color <- colorRamp(colors, bias = bias)
function(x) rgb(get_color(x), maxColorValue = 255)
}
off_rating_color <- make_color_pal(c("#ff2700", "#f8fcf8", "#44ab43"), bias = 1.3)
off_rating_color2 <- make_color_pal(c("#44ab43", "#f8fcf8", "#ff2700"), bias = 1.3)
knockout_pct_color <- make_color_pal(c("#009c1a", "#22b600", "#26cc00", "#7be382", "#d2f2d4", "#ffdc73", "#ffcf40", "#ffbf00", "#bf9b30", "#a67c00"), bias = 2)
# Icon to indicate trend: unchanged, up, down, or new
trend_indicator <- function(value = c("unchanged", "up", "down", "new")) {
value <- match.arg(value)
label <- switch(value,
unchanged = "Unchanged", up = "Trending up",
down = "Trending down", new = "New")
# Add img role and tooltip/label for accessibility
args <- list(role = "img", title = label)
if (value == "unchanged") {
args <- c(args, list("–", style = "color: #666; font-weight: 700"))
} else if (value == "up") {
args <- c(args, list(shiny::icon("caret-up"), style = "color: #1ed760"))
} else if (value == "down") {
args <- c(args, list(shiny::icon("caret-down"), style = "color: #cd1a2b"))
} else {
args <- c(args, list(shiny::icon("circle"), style = "color: #2e77d0; font-size: 10px"))
}
do.call(span, args)
}
tbl <- reactable(
epid_report,
pagination = FALSE,
defaultColGroup = colGroup(headerClass = "group-header"),
columnGroups = list(
colGroup(name = "Transmission", columns = trans_cols),
colGroup(name = "Testing", columns = test_cols),
colGroup(name = "Healthcare capacity", columns = capacity_cols),
colGroup(name = "Vaccination", columns = vax_cols)
),
defaultColDef = colDef(class = "cell", headerClass = "header"),
columns = list(
state = colDef(
maxWidth = 90,
headerStyle = list(fontWeight = 400),
name="State",
cell = function(value) {
img_src <- knitr::image_uri(sprintf("../images/%s.png", value))
image <- img(src = img_src, height = "36px", alt = "")
tagList(
div(style = list(display = "inline-block", width = "70px"), image),
value
)
}
),
# date = colDef(defaultSortOrder = "asc", align = "center", maxWidth = 75, name="Date",
# class = "cell group", headerStyle = list(fontWeight = 700)),
mean_ir = number_col_column(name = "7-day IR"),
perc_change_ir = change_column(
name = "% change*",
cell = function(value) {
scaled <- 1-(value - min(epid_report$perc_change_ir)) / (max(epid_report$perc_change_ir) - min(epid_report$perc_change_ir))
color <- off_rating_color(scaled)
value <- format(round(value, 1), nsmall = 1)
div(class = "date-rating", style = list(background = color), value)
}
),
mean_mr = number_col_column(name = "7-day MR"),
perc_change_mr = change_column(
name = "% change*",
cell = function(value) {
scaled <- 1-(value - min(epid_report$perc_change_mr)) / (max(epid_report$perc_change_mr) - min(epid_report$perc_change_mr))
color <- off_rating_color(scaled)
value <- format(round(value, 1), nsmall = 1)
div(class = "date-rating", style = list(background = color), value)
}
),
mean_rt_full = number_column(name = "Rt", maxWidth = 70),
perc_change_rt = change_column(
name = "% change*",
cell = function(value) {
scaled <- 1-(value - min(epid_report$perc_change_rt)) / (max(epid_report$perc_change_rt) - min(epid_report$perc_change_rt))
color <- off_rating_color(scaled)
value <- format(round(value, 1), nsmall = 1)
div(class = "date-rating", style = list(background = color), value)
}
),
mean_tpr = perc_column(name = "TPR (%)"),
trend_tpr = colDef(
header = span("TPR trend", class = "sr-only"),
sortable = FALSE,
align = "center",
width = 30,
cell = function(value) trend_indicator(value)
),
mean_tr = number_col_column(name = "TR"),
perc_change_tr = change_column(
name = "% change*",
cell = function(value) {
scaled <- 1-(value - min(epid_report$perc_change_tr)) / (max(epid_report$perc_change_tr) - min(epid_report$perc_change_tr))
color <- off_rating_color(scaled)
value <- format(round(value, 1), nsmall = 1)
div(class = "date-rating", style = list(background = color), value)
}
),
mean_bor = perc_column(name = "BOR (%)"),
trend_bor = colDef(
header = span("BOR trend", class = "sr-only"),
sortable = FALSE,
align = "center",
width = 30,
cell = function(value) trend_indicator(value)
),
mean_ior = perc_column(name = "IOR (%)"),
trend_ior = colDef(
header = span("Trend", class = "sr-only"),
sortable = FALSE,
align = "center",
width = 30,
cell = function(value) trend_indicator(value)
),
mean_vor = perc_column(name = "VOR (%)"),
trend_vor = colDef(
header = span("Trend", class = "sr-only"),
sortable = FALSE,
align = "center",
width = 30,
cell = function(value) trend_indicator(value)
),
max_vax2 = perc_column(name = "Full-dose (%)"),
trend_vax2 = colDef(
header = span("Trend", class = "sr-only"),
sortable = FALSE,
align = "center",
width = 30,
cell = function(value) trend_indicator(value)
),
max_booster = perc_column(name = "Booster (%)"),
trend_booster = colDef(
header = span("Trend", class = "sr-only"),
sortable = FALSE,
align = "center",
width = 30,
cell = function(value) trend_indicator(value)
)
),
# Emphasize borders between groups when sorting by group
rowClass = JS("
function(rowInfo, state) {
const firstSorted = state.sorted[0]
if (firstSorted && firstSorted.id === 'group') {
const nextRow = state.pageRows[rowInfo.viewIndex + 1]
if (nextRow && rowInfo.row.group !== nextRow.group) {
return 'group-last'
}
}
}"
),
showSortIcon = FALSE,
borderless = TRUE,
class = "standings-table")
div(class = "standings",
div(class = "title",
h2(" "),
""
),
tbl,
"*IR=incidence rate, MR=mortality rate, TR=testing rate, TPR=test-positivity ratio, Rt=time-varying reproductive number, BOR=Bed-occupancy rate, IOR= ICU-occupancy rate, VOR=ventilator-utilisation rate, % change calculated as the percentage change of indicator compared to the last week"
)
saveRDS(tbl, '../plots/epid_report_tbl.rds')